SuperHack/SuperHack CD.bin/CODING/VBASIC/VBDLH02.ZIP/VBDE_SRC.ZIP/VBDELHA.BAS

BASIC Source File | 1996-03-08 | 58.4 KB | 1,233 lines

'===================================================
'Sample VB program using UNLHA.DLL
'VBDeLHA.Bas
'Original: Niiyama(HEROPA) [e-mail]
'English : Hitoshi Ozawa   [e-mail]
'===================================================
Option Explicit

Global Const APP_CAPTION = "VB De UNLHA"
Global Const APP_NAME = "Call UNLHA.DLL from VB"
Global Const APP_DATE = "1995/12/06"
Global Const APP_VERSION = "Version 0.2E"
Global Const APP_COPYRIGHT = "Niiyama(HEROPA)"
Global Const APP_COPYRIGHT2 = "[e-mail]"
Global Const APP_COPYRIGHT3 = "Hitoshi Ozawa"
Global Const APP_COPYRIGHT4 = "[e-mail]"
Global Const APP_COPYRIGHT5 = "http://www.bekkoame.or.jp/~h_ozawa/"
Global Const APP_INIFILE = "Niiyama.Ini"

Global gstrLzhFile          As String       'archive file
Global gstrTmpLzhFile       As String       'work file
Global gstrUnpackDir        As String       'extraction directory
Global gintfUnpackCancel    As Integer      'cancel flag for extraction directory
Global gintbSaveFlag        As Integer      'save flag for work file
Global gintbDirFlag         As Integer      'flag checking if extraction directory exists
Global gintbOverWriteFalg   As Integer      'extraction overwrite flag
Global gintbReadOnly        As Integer      'archive file ReadOnly attribute
Global gintWorkCount        As Integer      'number of working extracted files
Global gstrListViewOption   As String       'list display option
Global gstrMRUFile()        As String       'used LZH file
Global gstrHelpFile         As String       'help file
Global gintFileMaxLen       As Integer      'maximum characters in file name in list box

Global glngColorBTNHIGHLIGHT    As Long         '3D picture (white)
Global glngColorBTNTEXT         As Long         '3D picture (black)
Global glngColorBTNSHADOW       As Long         '3D picture (dark grey)
Global glngColorBTNFACE         As Long         '3D picture (grey)
Global glngColorWINDOW          As Long         'TipHelp (color of text window)

Global gintCXBORDER         As Integer      'system size (frame of form)
Global gintCYBORDER         As Integer      'system size (frame of form)
Global gintCYCAPTION        As Integer      'system size (height of caption)
Global gintCXDLGFRAME       As Integer      'system size (dialog frame)
Global gintCYDLGFRAME       As Integer      'system size (dialog frame)
Global gintCYCURSOR         As Integer      'system size (cursor height)
Global gintCXVSCROLL        As Integer      'system size (width of vertical scroll bar)
Global gintCYHSCROLL        As Integer      'system size (height of horizontal scroll bar)

Global gintWinVer           As Integer      'Windows version
Global gintbTipHelp         As Integer      'TipHelp option flag
Global gintParenthWnd       As Integer      'TipHelp parent window handle referring to frmToolTip
Global gintTiphWnd          As Integer      'TipHelp parent control handle

'-------------------------------------------------------------------
'Constant declaration to call Help
Global Const HLP_MAIN = &H0&
Global Const HLP_GAIYOU = &H100&
Global Const HLP_INSTALL = &H200&
Global Const HLP_KAKUBU = &H300&
Global Const HLP_ETC = &H400&
Global Const HLP_HISTORY = &H500&
Global Const HLP_COPYRIGHT = &H600&
Global Const HLP_MNUFILENEW = &H311&
Global Const HLP_MNUFILEOPEN = &H312&
Global Const HLP_MNUFILESAVE = &H313&
Global Const HLP_MNUFILESAVEAS = &H314&
Global Const HLP_MNUFILESFX = &H315&
Global Const HLP_MNUFILEEXIT = &H316&
Global Const HLP_MNUEDITUNDO = &H321&
Global Const HLP_MNUEDITALLSELECT = &H322&
Global Const HLP_MNUEDITPACK = &H323&
Global Const HLP_MNUEDITUNPACK = &H324&
Global Const HLP_MNUEDITDELETE = &H325&
Global Const HLP_MNUEDITTEST = &H326&
Global Const HLP_MNUVIEWCONFIG = &H331&
Global Const HLP_MNUVIEWTIPHELP = &H332&
Global Const HLP_MNUVIEWINFO = &H333&
Global Const HLP_MNUVIEWRUN = &H334&
Global Const HLP_MNUVIEWTEXT = &H335&
Global Const HLP_MNUHELPCONTENTS = &H341&
Global Const HLP_MNUHELPSEARCH = &H342&
Global Const HLP_MNUHELPON = &H343&
Global Const HLP_MNUHELPABOUT = &H344&
Global Const HLP_DLGVIEWCONFIG = &H700&
Global Const HLP_DLGCHOOSEDIR = &H800&
Global Const HLP_DLGABOUT = &H900&

'-------------------------------------------
Type tagPoint
    X       As Integer
    y       As Integer
End Type

Type tagRECT
    Left    As Integer
    Top     As Integer
    Right   As Integer
    Bottom  As Integer
End Type

Global gtagTxtViewRECT As tagRECT

' Define open file information
Type tagOFSTRUCT
    strBytes     As String * 1               ' size of OFSTRUCT structure in bytes
    strFixedDisk As String * 1               ' flag checking if file is on hard disk
    intErrCode   As Integer                  ' error value when OpenFile failed
    strReserved  As String * 4               ' reserved
    strPathName  As String * 128             ' file path
End Type

Type tagWINDOWPLACEMENT
    length              As Integer
    flags               As Integer
    showCmd             As Integer
    ptMinPosition       As tagPoint
    ptMaxPosition       As tagPoint
    rcNormalPosition    As tagRECT
End Type

'-------------------------------------------
Global Const GFSR_SYSTEMRESOURCES = &H0      ' free system resource
Global Const SW_SHOWNA = 8
Global Const SW_RESTORE = 9
Global Const SW_HIDE = 0
Global Const SWP_NOSIZE = &H1
Global Const SWP_NOMOVE = &H2
Global Const SWP_NOACTIVATE = &H10
Global Const SWP_SHOWWINDOW = &H40
Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2
Global Const SM_CXBORDER = 5        'width of window frame
Global Const SM_CYBORDER = 6        'width of vertical component of window frame
Global Const SM_CYCAPTION = 4       'height of form caption
Global Const SM_CXDLGFRAME = 7      'width of horizontal component of dialog box frame
Global Const SM_CYDLGFRAME = 8      'width of vertical component of dialog box frame
Global Const SM_CXFULLSCREEN = 16   'width of client area when window is maximized
Global Const SM_CYFULLSCREEN = 17   'height of client aread when window is maximized
Global Const SM_CYCURSOR = 14       'height of mouse cursor
Global Const SM_CXVSCROLL = 2       'width of vertical scroll bar
Global Const SM_CYHSCROLL = 3       'height of horizontal scroll bar
Global Const COLOR_BTNFACE = 15         'shadow of push button
Global Const COLOR_BTNHIGHLIGHT = 20    'selected button in control
Global Const COLOR_BTNSHADOW = 16       'green shadow of push button
Global Const COLOR_BTNTEXT = 18         'push button text
Global Const COLOR_WINDOW = 5
Global Const WM_USER = &H400
Global Const EM_SETREADONLY = (WM_USER + 31)            'set text box write attribute
Global Const LB_SETHORIZONTALEXTENT = (WM_USER + 21)    'set horizontal scroll bar to a list box
Global Const LB_SETSEL = (WM_USER + 6)                  'list box selection status
Global Const LB_SETTABSTOPS = (WM_USER + 19)            'list box tags
Global Const OF_EXIST = &H4000               ' close file immediately after opening it
Global Const SRCAND = &H8800C6      ' (DWORD) dest = source AND dest
Global Const SRCINVERT = &H660046   ' (DWORD) dest = source XOR dest
Global Const GWW_HINSTANCE = (-6)
Global Const MF_BYPOSITION = &H400
'Help
Global Const HELP_CONTEXT = &H1           'Help topics
Global Const HELP_QUIT = &H2              'Quit Help file
Global Const HELP_INDEX = &H3             'Index
'Global Const HELP_CONTENTS = &H3
Global Const HELP_HELPONHELP = &H4        'How to use help
'Global Const HELP_SETINDEX = &H5          'current index
'Global Const HELP_SETCONTENTS = &H5
'Global Const HELP_CONTEXTPOPUP = &H8
'Global Const HELP_FORCEFILE = &H9
Global Const HELP_KEY = &H101             'keyword search
Global Const HELP_COMMAND = &H102
Global Const HELP_PARTIALKEY = &H105
'Global Const HELP_MULTIKEY = &H201

'-------------------------------------------
Declare Sub GetCursorPos Lib "User" (lppt As tagPoint)
Declare Sub GetWindowRect Lib "User" (ByVal hWnd As Integer, lprc As tagRECT)
Declare Function ShowWindow Lib "User" (ByVal hWnd As Integer, ByVal nCmdShow As Integer) As Integer
Declare Function GetActiveWindow Lib "User" () As Integer
Declare Function FindWindow Lib "User" (ByVal lpClassName As Any, ByVal lpszWindow As Any) As Integer
Declare Function GetLastActivePopup Lib "User" (ByVal hwndOwnder As Integer) As Integer
Declare Function BringWindowToTop Lib "User" (ByVal hWnd As Integer) As Integer
Declare Function SetWindowPos Lib "User" (ByVal hWnd As Integer, ByVal hwndInsertAfter As Integer, ByVal X As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal fuFlag As Integer) As Integer
'Needed to display Windows3.1 information with version
Declare Sub ShellAbout Lib "Shell" (ByVal hWnd As Integer, ByVal lpAppName As String, ByVal lpMoreInfo As String, ByVal hIcon As Integer)

Declare Function GetSystemMetrics Lib "User" (ByVal nIndex As Integer) As Integer
Declare Function GetSysColor Lib "User" (ByVal nDspElement As Integer) As Long

Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal uMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long

' file creation, open, modification, deletion
Declare Function OpenFile Lib "Kernel" (ByVal lpszFilename As String, lpOpenBuff As tagOFSTRUCT, ByVal fuMode As Integer) As Integer

Declare Function BitBlt Lib "Gdi" (ByVal hdcDest As Integer, ByVal nXDest As Integer, ByVal nYDest As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hdcSrc As Integer, ByVal nXSrc As Integer, ByVal nYSrc As Integer, ByVal dwRop As Long) As Integer

'for CTL3D.DLL
Declare Function GetModuleHandle Lib "Kernel" (ByVal lpszModuleName As String) As Integer
Declare Function GetWindowWord Lib "User" (ByVal hWnd As Integer, ByVal nOffset As Integer) As Integer

Declare Function Ctl3dRegister Lib "CTL3D.DLL" (ByVal hInstance As Integer) As Integer
Declare Function Ctl3dAutoSubClass Lib "CTL3D.DLL" (ByVal hInstance As Integer) As Integer
Declare Function Ctl3dUnregister Lib "CTL3D.DLL" (ByVal hInstance As Integer) As Integer
Declare Function Ctl3dGetVer Lib "CTL3D.DLL" () As Integer

Declare Function ExtractIcon Lib "Shell" (ByVal hinst As Integer, ByVal lpszExeName As String, ByVal iIcon As Integer) As Integer

Declare Function GetTempFileName Lib "Kernel" (ByVal cDriveLetter As Integer, ByVal lpPrefixString As String, ByVal wUnique As Integer, ByVal lpTempFileName As String) As Integer

Declare Function GetVersion Lib "Kernel" () As Long

Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpszSection As String, ByVal lpszEntry As String, ByVal lpszString As String, ByVal lpszFilename As String) As Integer
Declare Function GetPrivateProfileInt Lib "Kernel" (ByVal lpszSection As String, ByVal lpszEntry As String, ByVal default As Integer, ByVal lpszFilename As String) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpszSection As String, ByVal lpszEntry As String, ByVal lpszDefault As String, ByVal lpszReturnBuffer As String, ByVal cbReturnBuffer As Integer, ByVal lpszFilename As String) As Integer

Declare Function GetWindowPlacement Lib "User" (ByVal hWnd As Integer, lpwndpl As tagWINDOWPLACEMENT) As Integer
Declare Function SetWindowPlacement Lib "User" (ByVal hWnd As Integer, lpwndpl As tagWINDOWPLACEMENT) As Integer

Declare Function DeleteMenu Lib "User" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
Declare Function GetSystemMenu Lib "User" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
Declare Function GetSubMenu Lib "User" (ByVal hMenu As Integer, ByVal nPos As Integer) As Integer
Declare Function GetMenu Lib "User" (ByVal hWnd As Integer) As Integer
Declare Function TrackPopupMenu Lib "User" (ByVal hMenu As Integer, ByVal wFlags As Integer, ByVal X As Integer, ByVal y As Integer, ByVal nReserved As Integer, ByVal hWnd As Integer, lpReserved As Any) As Integer


Declare Function FindExecutable Lib "Shell" (ByVal lpszFile As String, ByVal lpszDir As String, ByVal lpszResult As String) As Integer
Declare Function WinExec Lib "Kernel" (ByVal lpCmdLine As String, ByVal nCmdShow As Integer) As Integer
Declare Function GetModuleUsage Lib "Kernel" (ByVal hModule As Integer) As Integer

' Get percentage of free system resource
Declare Function GetFreeSystemResources Lib "User" (ByVal fuSysResource As Integer) As Integer

Declare Function WinHelp Lib "User" (ByVal hWnd As Integer, ByVal lpzHelpFile As String, ByVal fuCommand As Integer, dwData As Any) As Integer
'-------------------------------------------
'Visual Basic 3.0 Constant.Txt

' Show method
Global Const MODAL = 1                  'modal
'Global Const MODELESS = 0              'modeless

' MsgBox parameter
Global Const MB_OK = 0                 ' OK button only
Global Const MB_OKCANCEL = 1           ' OK and cancel buttons
Global Const MB_ABORTRETRYIGNORE = 2   ' cancel, retry, and ignore buttons
Global Const MB_YESNOCANCEL = 3        ' yes, no, and cancel buttons
Global Const MB_YESNO = 4              ' yes and no buttons
Global Const MB_RETRYCANCEL = 5        ' retry and cancel buttons

Global Const MB_ICONSTOP = 16          ' Stop
Global Const MB_ICONQUESTION = 32      ' Question
Global Const MB_ICONEXCLAMATION = 48   ' Exclamation
Global Const MB_ICONINFORMATION = 64   ' Information

Global Const MB_APPLMODAL = 0          ' application modal
Global Const MB_DEFBUTTON1 = 0         ' set button1 to default
Global Const MB_DEFBUTTON2 = 256       ' set button2 to default
'Global Const MB_DEFBUTTON3 = 512      ' set button3 to default
'Global Const MB_SYSTEMMODAL = 4096    ' system mode

' Return code from MsgBox button
Global Const IDOK = 1                  ' OK button
Global Const IDCANCEL = 2              ' cancel button
Global Const IDABORT = 3               ' abort button
Global Const IDRETRY = 4               ' retry button
Global Const IDIGNORE = 5              ' ignore button
Global Const IDYES = 6                 ' yes button
Global Const IDNO = 7                  ' no button

' SetAttr, Dir, GetAttr functions
'Global Const ATTR_NORMAL = 0           ' normal file
Global Const ATTR_READONLY = 1          ' read-only file
'Global Const ATTR_HIDDEN = 2           ' hidden file
'Global Const ATTR_SYSTEM = 4           ' system file
'Global Const ATTR_VOLUME = 8           ' volume label
'Global Const ATTR_DIRECTORY = 16       ' MS-DOS directory
'Global Const ATTR_ARCHIVE = 32         ' archive attribute (not backed up)

' WindowState
Global Const NORMAL = 0    ' 0 - normal
Global Const MINIMIZED = 1 ' 1 - minimized
'Global Const MAXIMIZED = 2 ' 2 - maximized

' Check Value
Global Const UNCHECKED = 0 ' 0 - unchecked
Global Const CHECKED = 1   ' 1 - checked
'Global Const GRAYED = 2    ' 2 - unselectable

' Button parameter masks
'Global Const LEFT_BUTTON = 1
Global Const RIGHT_BUTTON = 2
'Global Const MIDDLE_BUTTON = 4

Sub CopyFile (strSrcFileName As String, strDstFileName As String)
    Dim strMsg As String
    Dim intType As Integer
On Error GoTo CopyErr
    FileCopy strSrcFileName$, strDstFileName$
    Exit Sub
CopyErr:
    Select Case Err
    Case Else
    strMsg$ = "Failed to copy file " & strSrcFileName$ & ". CopyFile Err: " & Err
    intType% = MB_OK Or MB_ICONEXCLAMATION Or MB_APPLMODAL
    MsgBox strMsg$, intType%, APP_CAPTION
    End Select
    Resume Next
End Sub

Sub DeleteSwitchTo (DstForm As Form)
    'adjust system menu like a dialog box
    Dim inthMenu As Integer, intResponce As Integer
    inthMenu% = GetSystemMenu(DstForm.hWnd, 0)
    intResponce% = DeleteMenu(inthMenu%, 5, MF_BYPOSITION)
    intResponce% = DeleteMenu(inthMenu%, 6, MF_BYPOSITION)
    intResponce% = DeleteMenu(inthMenu%, 6, MF_BYPOSITION)
End Sub

Sub Draw3DButton (DstControl As Control, flag As Integer)
    'Draw PictureBox like 3D button
    'DstControl  : Picture control name
    'flag : True  raised
    '       False lowered
    DstControl.AutoRedraw = True
    DstControl.Cls
    If flag Then
        DstControl.DrawWidth = 1
        DstControl.Line (0, 0)-(DstControl.ScaleWidth - 1, 0), glngColorBTNHIGHLIGHT
        DstControl.Line (0, 1)-(0, DstControl.ScaleHeight - 1), glngColorBTNHIGHLIGHT
        DstControl.Line (DstControl.ScaleWidth - 1, 0)-(DstControl.ScaleWidth - 1, DstControl.ScaleHeight), glngColorBTNTEXT
        DstControl.Line (0, DstControl.ScaleHeight - 1)-(DstControl.ScaleWidth - 1, DstControl.ScaleHeight - 1), glngColorBTNTEXT
        DstControl.Line (1, 1)-(DstControl.ScaleWidth - 2, 1), glngColorBTNFACE
        DstControl.Line (1, 2)-(1, DstControl.ScaleHeight - 2), glngColorBTNFACE
        DstControl.Line (DstControl.ScaleWidth - 2, 1)-(DstControl.ScaleWidth - 2, DstControl.ScaleHeight - 1), glngColorBTNSHADOW
        DstControl.Line (1, DstControl.ScaleHeight - 2)-(DstControl.ScaleWidth - 2, DstControl.ScaleHeight - 2), glngColorBTNSHADOW
    Else
        DstControl.DrawWidth = 1
        DstControl.Line (0, 0)-(DstControl.ScaleWidth - 1, 0), glngColorBTNSHADOW
        DstControl.Line (0, 1)-(0, DstControl.ScaleHeight - 1), glngColorBTNSHADOW
        DstControl.Line (DstControl.ScaleWidth - 1, 0)-(DstControl.ScaleWidth - 1, DstControl.ScaleHeight), glngColorBTNHIGHLIGHT
        DstControl.Line (0, DstControl.ScaleHeight - 1)-(DstControl.ScaleWidth - 1, DstControl.ScaleHeight - 1), glngColorBTNHIGHLIGHT
        DstControl.Line (1, 1)-(DstControl.ScaleWidth - 2, 1), glngColorBTNTEXT
        DstControl.Line (1, 2)-(1, DstControl.ScaleHeight - 2), glngColorBTNTEXT
        DstControl.Line (DstControl.ScaleWidth - 2, 1)-(DstControl.ScaleWidth - 2, DstControl.ScaleHeight - 1), glngColorBTNFACE
        DstControl.Line (1, DstControl.ScaleHeight - 2)-(DstControl.ScaleWidth - 2, DstControl.ScaleHeight - 2), glngColorBTNFACE
    End If
    DstControl.AutoRedraw = False
End Sub

Sub Draw3DControl (DstControl As Control)
    'To make is look 3D, lines are drawn on a form with DstControl.
    'Tried to make it look like Ctrl3D.Dll is being used.
    DstControl.Parent.Line (DstControl.Left - 1 * Screen.TwipsPerPixelX, DstControl.Top - 1 * Screen.TwipsPerPixelY)-(DstControl.Left + DstControl.Width, DstControl.Top - 1 * Screen.TwipsPerPixelY), glngColorBTNTEXT&
    DstControl.Parent.Line (DstControl.Left - 1 * Screen.TwipsPerPixelX, DstControl.Top)-(DstControl.Left - 1 * Screen.TwipsPerPixelX, DstControl.Top + DstControl.Height), glngColorBTNTEXT&
    DstControl.Parent.Line (DstControl.Left - 2 * Screen.TwipsPerPixelX, DstControl.Top - 2 * Screen.TwipsPerPixelY)-(DstControl.Left + DstControl.Width + 2 * Screen.TwipsPerPixelX, DstControl.Top - 2 * Screen.TwipsPerPixelY), glngColorBTNSHADOW&
    DstControl.Parent.Line (DstControl.Left - 2 * Screen.TwipsPerPixelX, DstControl.Top - 1 * Screen.TwipsPerPixelY)-(DstControl.Left - 2 * Screen.TwipsPerPixelX, DstControl.Top + DstControl.Height + 1 * Screen.TwipsPerPixelY), glngColorBTNSHADOW&
    DstControl.Parent.Line (DstControl.Left - 2 * Screen.TwipsPerPixelX, DstControl.Top + DstControl.Height + 1 * Screen.TwipsPerPixelY)-(DstControl.Left + DstControl.Width + 2 * Screen.TwipsPerPixelX, DstControl.Top + DstControl.Height + 1 * Screen.TwipsPerPixelY), glngColorBTNHIGHLIGHT&
    DstControl.Parent.Line (DstControl.Left + DstControl.Width + 1 * Screen.TwipsPerPixelX, DstControl.Top - 2 * Screen.TwipsPerPixelY)-(DstControl.Left + DstControl.Width + 1 * Screen.TwipsPerPixelX, DstControl.Top + DstControl.Height + 1 * Screen.TwipsPerPixelY), glngColorBTNHIGHLIGHT&
End Sub

Sub Draw3DForm (DstForm As Form)
    'make form look 3D.
    If gintWinVer% <= 310 Then
    'targeted only for Windows 3.1
    DstForm.Line (0, 0)-(DstForm.ScaleWidth, 0), glngColorBTNHIGHLIGHT&
    DstForm.Line (0, 0)-(0, DstForm.ScaleHeight - 1 * Screen.TwipsPerPixelY), glngColorBTNHIGHLIGHT&
    DstForm.Line (0, DstForm.ScaleHeight - 1 * Screen.TwipsPerPixelY)-(DstForm.ScaleWidth, DstForm.ScaleHeight - 1 * Screen.TwipsPerPixelY), glngColorBTNSHADOW&
    DstForm.Line (DstForm.ScaleWidth - 1 * Screen.TwipsPerPixelX, 1 * Screen.TwipsPerPixelY)-(DstForm.ScaleWidth - 1 * Screen.TwipsPerPixelY, DstForm.ScaleHeight - 1 * Screen.TwipsPerPixelX), glngColorBTNSHADOW&
    End If
End Sub

Sub Draw3DLine (DstForm As Form, x1%, y1%, x2%, y2%, S%)
'draw 3D line on form
    If S% Then
    ' raised
    DstForm.Line (x1 + 1 * Screen.TwipsPerPixelX, y1 + 1 * Screen.TwipsPerPixelY)-(x2 + 1 * Screen.TwipsPerPixelX, y2 + 1 * Screen.TwipsPerPixelY), glngColorBTNSHADOW&, B
    DstForm.Line (x1, y1)-(x2, y2), glngColorBTNHIGHLIGHT&, B
    Else
    ' lowered
    DstForm.Line (x1, y1)-(x2, y2), glngColorBTNSHADOW&, B
    DstForm.Line (x1 + 1 * Screen.TwipsPerPixelX, y1 + 1 * Screen.TwipsPerPixelY)-(x2 + 1 * Screen.TwipsPerPixelX, y2 + 1 * Screen.TwipsPerPixelY), glngColorBTNHIGHLIGHT&, B
    End If

End Sub

'--------------------------------------
'Draw tool bar
'DstControl : targeted control(Picture)
'--------------------------------------
Sub Draw3DPanel (DstControl As Control)
    DstControl.AutoRedraw = True
    DstControl.BackColor = glngColorBTNFACE
    'DstControl.Width = DstControl.Parent.ScaleWidth
    DstControl.Line (0, 0)-(DstControl.ScaleWidth, 0), glngColorBTNHIGHLIGHT
    DstControl.Line (0, DstControl.ScaleHeight - 2 * Screen.TwipsPerPixelY)-(DstControl.ScaleWidth, DstControl.ScaleHeight - 2 * Screen.TwipsPerPixelY), glngColorBTNSHADOW
    DstControl.Line (0, DstControl.ScaleHeight - 1 * Screen.TwipsPerPixelY)-(DstControl.ScaleWidth, DstControl.ScaleHeight - 1 * Screen.TwipsPerPixelY), glngColorBTNTEXT
    DstControl.AutoRedraw = False
End Sub

Sub DrawBitBlt (DstPic As PictureBox, SrcPic As PictureBox, intSelWidth As Integer, intIndex As Integer)
    Dim intReturnCode As Integer
    DstPic.AutoRedraw = True
    DstPic.Picture = LoadPicture()
    intReturnCode = BitBlt(DstPic.hDC, 0, 0, DstPic.ScaleWidth, DstPic.ScaleHeight, SrcPic.hDC, intSelWidth * intIndex, intSelWidth, SRCAND)
    intReturnCode = BitBlt(DstPic.hDC, 0, 0, DstPic.ScaleWidth, DstPic.ScaleHeight, SrcPic.hDC, intSelWidth * intIndex, 0, SRCINVERT)
    DstPic.Picture = DstPic.Image
    DstPic.AutoRedraw = False
End Sub

Function GetCtl3dVersion ()
    'get Ctl3D.DLL version
    Dim intRetCode As Integer, intWorked As Integer
    intRetCode = Ctl3dGetVer()
    intWorked = intRetCode And &HFFFF&
    GetCtl3dVersion = Format((intWorked \ 256) + ((intWorked Mod 256) / 100), "Fixed")
End Function

'get strFileName extension
Function GetFileExt (strFilename As String) As String
    Dim intLoopCount As Integer
    Dim strTmp As String

    For intLoopCount% = 1 To Len(strFilename$)
    strTmp$ = Right$(strFilename$, intLoopCount%)
    If InStr(strTmp$, "\") <> 0 Then
        strTmp$ = ""
        Exit For
    End If
    If InStr(strTmp$, ".") <> 0 Then
        strTmp$ = Right$(strTmp$, intLoopCount% - 1)
        Exit For
    End If
    strTmp$ = ""
    Next intLoopCount%

    GetFileExt$ = UCase$(strTmp$)

End Function

Function GetPrivateIni (strSection As String, strKey As String, strDefString As String, strIniFile As String) As String
'get string from private file
    Dim strBuf          As String * 255
    Dim intReturnCode   As Integer
    intReturnCode% = GetPrivateProfileString(strSection$, strKey$, strDefString$, strBuf$, Len(strBuf$), strIniFile$)
    GetPrivateIni$ = Left(strBuf$, intReturnCode%)
End Function

Function GetShortName (strLongPathName As String) As String
    Dim strDriveName As String
    Dim strLastPath As String
    'get drive name
    strDriveName$ = Left$(strLongPathName$, 3)

    'get last subdirectory name
    strLastPath$ = Mid$(strLongPathName$, 4)
    Do While InStr(strLastPath$, "\")
    strLastPath$ = Mid$(strLastPath$, InStr(strLastPath$, "\") + 1)
    Loop
    If Len(strDriveName$ & strLastPath$) >= Len(strLongPathName$) Then
    'if file resides in a root directory
    GetShortName$ = strLongPathName$
    Else
    'abbreviate partial path name
    GetShortName = strDriveName$ + "...\" + strLastPath$
    End If
End Function

Function GetTmpName (strFirst As String, strExt As String) As String
    Dim intReturnCode   As Integer
    Dim szBuf           As String * 144
    Dim strTmpFile      As String
    Dim strMsg          As String
    Dim intType         As Integer

    intReturnCode% = GetTempFileName(0, strFirst, 0, szBuf$)
    strTmpFile$ = Left$(szBuf$, InStr(szBuf$, Chr$(0)) - 1)
    If IsFile(strTmpFile$) = True Then
    Call KillFile(strTmpFile$)
    GetTmpName$ = Left$(strTmpFile$, Len(strTmpFile$) - 3) & strExt
    Else
    strMsg$ = "Unable to create work file."
    strMsg$ = strMsg$ & " Please make sure that there are ample free space in directory specified by TEMP environmental parameter."
    intType% = MB_OK Or MB_ICONSTOP Or MB_APPLMODAL
    MsgBox strMsg$, intType%, APP_CAPTION
    End If
End Function

'return Windows version. If 3.1, return 310
Function GetWindowsVersion ()
    Dim Ver As Long, WinVer As Long
    Ver = GetVersion()
    WinVer = Ver And &HFFFF&
    GetWindowsVersion = (WinVer Mod 256) * 100 + (WinVer \ 256)
End Function

'---------------------------
'check if file exists
'strFileName : file to search
'return code:   True   file exists
'               False  file does not exist
'---------------------------
Function IsFile (strFilename As String) As Integer
'Following is a merit of using the following routine instead of Visual Basic Dir function:
'True is returned when file exists in the current directory, Windows directory, System
'directory, or at any of the directory where path is set to.
    Dim udtOpenBuff As tagOFSTRUCT ' information of opened file
    Dim intRetCode As Integer     ' return code

    intRetCode = OpenFile(strFilename, udtOpenBuff, OF_EXIST)
    If intRetCode = (-1) Then
    IsFile = False
    Else
    IsFile = True
    End If
End Function

Function IsVBRunTime ()
  'Return code: True   if executed as EXE file
  '             False  if executed using VB.EXE
  Dim strMyExeFile As String
  'get full path of application
  strMyExeFile = App.Path
  If Right$(strMyExeFile, 1) <> "\" Then strMyExeFile = strMyExeFile & "\"
  strMyExeFile = strMyExeFile & App.EXEName & ".Exe"
  'check if file exists
  If Dir$(strMyExeFile, 0) = UCase$(App.EXEName & ".Exe") Then
    'check module handle
    If GetModuleHandle(strMyExeFile) <> 0 Then  'exists
      IsVBRunTime = True
      Exit Function
    End If
  End If
  IsVBRunTime = False
End Function

'delete file when error occurs
Sub KillFile (strFilename As String)
Dim strMsg As String
Dim intType As Integer
On Error GoTo KillErr
    If IsFile(strFilename$) = True Then
    Kill strFilename$
    End If
    Exit Sub
KillErr:
    strMsg$ = "Unable to delete file " & strFilename$ & ". KillFile Err: " & Err
    intType% = MB_OK Or MB_ICONEXCLAMATION Or MB_APPLMODAL
    MsgBox strMsg$, intType%, APP_CAPTION
    Resume Next
End Sub

'AddItem gstrTmpLzhFile$ list to DstListBox list box.
'Return number of items.
'Set DstListBox.Tag to maximum number of characters of added item.
Function LHAAddArchiveList (DstListBox As Control) As String
    Dim intHarcHnd          As Integer
    Dim tagIndividualinfo   As INDIVIDUALINFO
    Dim intReturnCode       As Integer
    Dim intArcCount         As Integer
    Dim intLoopCount        As Integer
    Dim lngReturnCode       As Long
    Dim strMsg              As String
    Dim intType             As Integer
    Dim strTmp              As String

    DstListBox.Clear    'clear list box
    DstListBox.Parent.BackColor = DstListBox.BackColor
    DstListBox.Visible = False
    gintFileMaxLen% = 0
    'total number of files in Lzh archive
    intArcCount% = UnlhaGetFileCount(gstrTmpLzhFile$)
    If intArcCount% > 1024 Then
    'if there are over 1024 files in the archive
    strMsg$ = "There are " & intArcCount% & " files but due to memory and processing speed constraint"
    strMsg$ = strMsg$ & Chr$(10) & " only 1024 files are displayed."
    intType% = MB_OK Or MB_ICONEXCLAMATION
    MsgBox strMsg$, intType%, APP_CAPTION
    intArcCount% = 1024
    End If

    DstListBox.Parent.Enabled = False
    Screen.MousePointer = 11  'sand clock
    'Lzh file handle
    intHarcHnd% = UnlhaOpenArchive(DstListBox.Parent.hWnd, gstrTmpLzhFile$, 0)

    'get current information on Lzh archive
    intReturnCode% = UnlhaFindFirst(intHarcHnd%, "*.*", tagIndividualinfo)
    'save information to list box
    strTmp$ = LHAMakeList(tagIndividualinfo)
    DstListBox.AddItem strTmp$
    'DstListBox.Tag = LenB(strTmp$)

    For intLoopCount% = 1 To intArcCount% - 1
    'get next lzh archive
    intReturnCode% = UnlhaFindNext(intHarcHnd%, tagIndividualinfo)
    'save information to list box
    strTmp$ = LHAMakeList(tagIndividualinfo)
    DstListBox.AddItem strTmp$
    'If DstListBox.Tag < LenB(strTmp$) Then DstListBox.Tag = LenB(strTmp$)
    Next intLoopCount%
    '---------------------------------------
    lngReturnCode& = UnlhaGetArcOriginalSize(intHarcHnd%)
    '---------------------------------------
    'release Lzh archive handle
    intReturnCode% = UnlhaCloseArchive(intHarcHnd%)

    'set return code
    LHAAddArchiveList$ = "Total Files: " & UnlhaGetFileCount(gstrTmpLzhFile$) & " (" & Format$(lngReturnCode&, "#,###") & "bytes)"
    DstListBox.Visible = True
    DstListBox.Parent.Enabled = True
    Screen.MousePointer = 0  'current value
End Function

'check UNLHA.DLL supported functions
Function LHACheckFunction () As String
    Dim strTmp As String
    strTmp$ = "UNLHA.DLL Version " & Format$((UnlhaGetVersion() / 100), "Fixed")
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_VERSION = " & UnlhaQueryFunctionList(ISARC_GET_VERSION)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_CURSOR_INTERVAL = " & UnlhaQueryFunctionList(ISARC_GET_CURSOR_INTERVAL)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_SET_CURSOR_INTERVAL = " & UnlhaQueryFunctionList(ISARC_SET_CURSOR_INTERVAL)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_BACK_GROUND_MODE = " & UnlhaQueryFunctionList(ISARC_GET_BACK_GROUND_MODE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_SET_BACK_GROUND_MODE = " & UnlhaQueryFunctionList(ISARC_SET_BACK_GROUND_MODE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_BACK_GROUND_MODE = " & UnlhaQueryFunctionList(ISARC_GET_BACK_GROUND_MODE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_SET_BACK_GROUND_MODE = " & UnlhaQueryFunctionList(ISARC_SET_BACK_GROUND_MODE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_CURSOR_MODE = " & UnlhaQueryFunctionList(ISARC_GET_CURSOR_MODE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_SET_CURSOR_MODE = " & UnlhaQueryFunctionList(ISARC_SET_CURSOR_MODE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_RUNNING = " & UnlhaQueryFunctionList(ISARC_GET_RUNNING)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_CHECK_ARCHIVE = " & UnlhaQueryFunctionList(ISARC_CHECK_ARCHIVE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_CONFIG_DIALOG = " & UnlhaQueryFunctionList(ISARC_CONFIG_DIALOG)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_FILE_COUNT = " & UnlhaQueryFunctionList(ISARC_GET_FILE_COUNT)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_QUERY_FUNCTION_LIST = " & UnlhaQueryFunctionList(ISARC_QUERY_FUNCTION_LIST)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_HOUT = " & UnlhaQueryFunctionList(ISARC_HOUT)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_STRUCTOUT = " & UnlhaQueryFunctionList(ISARC_STRUCTOUT)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_FILE_INFO = " & UnlhaQueryFunctionList(ISARC_GET_ARC_FILE_INFO)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_OPEN_ARCHIVE = " & UnlhaQueryFunctionList(ISARC_OPEN_ARCHIVE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_CLOSE_ARCHIVE = " & UnlhaQueryFunctionList(ISARC_CLOSE_ARCHIVE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_FIND_FIRST = " & UnlhaQueryFunctionList(ISARC_FIND_FIRST)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_FIND_NEXT = " & UnlhaQueryFunctionList(ISARC_FIND_NEXT)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_EXTRACT = " & UnlhaQueryFunctionList(ISARC_EXTRACT)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_ADD = " & UnlhaQueryFunctionList(ISARC_ADD)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_MOVE = " & UnlhaQueryFunctionList(ISARC_MOVE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_DELETE = " & UnlhaQueryFunctionList(ISARC_DELETE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_FILE_NAME = " & UnlhaQueryFunctionList(ISARC_GET_ARC_FILE_NAME)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_FILE_SIZE = " & UnlhaQueryFunctionList(ISARC_GET_ARC_FILE_SIZE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_ORIGINAL_SIZE = " & UnlhaQueryFunctionList(ISARC_GET_ARC_ORIGINAL_SIZE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_COMPRESSED_SIZE = " & UnlhaQueryFunctionList(ISARC_GET_ARC_COMPRESSED_SIZE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_RATIO = " & UnlhaQueryFunctionList(ISARC_GET_ARC_RATIO)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_DATE = " & UnlhaQueryFunctionList(ISARC_GET_ARC_DATE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_TIME = " & UnlhaQueryFunctionList(ISARC_GET_ARC_TIME)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_OS_TYPE = " & UnlhaQueryFunctionList(ISARC_GET_ARC_OS_TYPE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ARC_IS_SFX_FILE = " & UnlhaQueryFunctionList(ISARC_GET_ARC_IS_SFX_FILE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_FILE_NAME = " & UnlhaQueryFunctionList(ISARC_GET_FILE_NAME)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ORIGINAL_SIZE = " & UnlhaQueryFunctionList(ISARC_GET_ORIGINAL_SIZE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_COMPRESSED_SIZE = " & UnlhaQueryFunctionList(ISARC_GET_COMPRESSED_SIZE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_RATIO = " & UnlhaQueryFunctionList(ISARC_GET_RATIO)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_DATE = " & UnlhaQueryFunctionList(ISARC_GET_DATE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_TIME = " & UnlhaQueryFunctionList(ISARC_GET_TIME)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_CRC = " & UnlhaQueryFunctionList(ISARC_GET_CRC)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_ATTRIBUTE = " & UnlhaQueryFunctionList(ISARC_GET_ATTRIBUTE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_OS_TYPE = " & UnlhaQueryFunctionList(ISARC_GET_OS_TYPE)
    strTmp$ = strTmp$ & Chr$(13) & Chr$(10) & "ISARC_GET_METHOD = " & UnlhaQueryFunctionList(ISARC_GET_METHOD)
    LHACheckFunction$ = strTmp$ & Chr$(13) & Chr$(10)
End Function

'delete file in Lzh archive
Function LHADelete (strFilename As String) As Integer
    Dim intReturnCode   As Integer
    Dim strCommandLine  As String
    Dim strBuffer       As String * 10000
    Dim strMsg          As String
    Dim intType         As Integer
    Dim strOption       As String
    strMsg$ = "Delete file " & strFilename$
    intType% = MB_YESNOCANCEL Or MB_ICONQUESTION Or MB_DEFBUTTON1
    Select Case MsgBox(strMsg$, intType%, APP_CAPTION)
    Case IDYES
    strOption$ = "-n "    'do not display extraction progress dialog box
    strCommandLine$ = "d " & strOption$ & gstrTmpLzhFile$ & " " & strFilename$
    intReturnCode% = Unlha(strCommandLine$, strBuffer$, Len(strBuffer$))
    LHADelete% = LHAErrCode(intReturnCode%)
    gintbSaveFlag% = True
    Case IDNO
    LHADelete% = 0
    Case IDCANCEL
    LHADelete% = (-1)
    End Select

End Function

Function LHAErrCode (intReturnCode As Integer) As Integer
    Dim strMsg  As String
    Dim intType As Integer

    Select Case intReturnCode%
    Case 0  'normal
    LHAErrCode% = 0
    Exit Function
    Case ERROR_DISK_SPACE           'Not enough disk space to extract file
    strMsg$ = "Not enough disk space to extract file."
    Case ERROR_READ_ONLY            'Read only file already exists
    strMsg$ = "Read only file already exists."
    Case ERROR_USER_SKIP            'Skip extraction upon user request
    strMsg$ = "Skip extraction upon user request."
    Case ERROR_FILE_CRC             'Archive file CRC file error
    strMsg$ = "Archive file CRC file error."
    Case ERROR_FILE_OPEN            'Unable to open file during extraction
    strMsg$ = "Unable to open file during extraction."
    Case ERROR_MORE_FRESH           'More current file already exists
    strMsg$ = "More current file already exists."
    Case ERROR_NOT_EXIST            'File does not exists at specified directory
    strMsg$ = "File does not exists at specified directory."
    Case ERROR_DIRECTORY            'Unable to make directory
    strMsg$ = "Unable to make directory."
    Case ERROR_CANNOT_WRITE         'Write error while extracting file
    strMsg$ = "Write error while extracting file."
    Case ERROR_HUFFMAN_CODE         'Broken Huffman code in LZH file
    strMsg$ = "Broken Huffman code in LZH file."
    Case ERROR_COMMENT_HEADER       'Broken comment header in LZH file
    strMsg$ = "Broken comment header in LZH file."
    Case ERROR_HEADER_CRC           'Header CRC error in LZH file
    strMsg$ = "Header CRC error in LZH file."
    Case ERROR_HEADER_BROKEN        'Broken header in LZH file
    strMsg$ = "Broken header in LZH file."
    Case ERROR_ARC_FILE_OPEN        'Unable to open LZH file
    strMsg$ = "Unable to open LZH file."
    Case ERROR_NOT_ARC_FILE         'Specified archive file is not LZH file
    strMsg$ = "Specified archive file is not LZH file."
    Case ERROR_CANNOT_READ          'Read error when reading LZH file
    strMsg$ = "Read error when reading LZH file."
    Case ERROR_FILE_STYLE           'Specified archive file is not LZH file
    strMsg$ = "Specified archive file is not LZH file."
    Case ERROR_COMMAND_NAME         'Illegal command
    strMsg$ = "Illegal command."
    Case ERROR_MORE_HEAP_MEMORY     'Not enough heap memory for work
    strMsg$ = "Not enough heap memory for work."
    Case ERROR_ENOUGH_MEMORY        'Not enough global memory
    strMsg$ = "Not enough global memory."
    Case ERROR_ALREADY_RUNNING      'UNLHA.DLL already running from different process
    strMsg$ = "UNLHA.DLL already running from different process."
    Case ERROR_USER_CANCEL          'Extraction terminated by user's request
    strMsg$ = "Extraction terminated by user's request."
    Case ERROR_HARC_ISNOT_OPENED    'UnlhaFindFirst() called before UnlhaOpenArchive() called to associate file to a handle
    strMsg$ = "UnlhaFindFirst() called before UnlhaOpenArchive() called to associate file to a handle."
    Case ERROR_NOT_SEARCH_MODE      'UnlhaFindNext() called before UnlhaFindFirst() called or either function called before UnlhaGetFileName() called
    strMsg$ = "UnlhaFindNext() called before UnlhaFindFirst() called or either function called before UnlhaGetFileName() called."
    Case ERROR_NOT_SUPPORT          'API not supported by UNLHA.DLL called
    strMsg$ = "API not supported by UNLHA.DLL called."
    Case ERROR_TIME_STAMP           'Illegal date/time format
    strMsg$ = "Illegal date/time format."
    Case ERROR_TMP_OPEN             'Unable to open work file
    strMsg$ = "Unable to open work file."
    Case ERROR_LONG_FILE_NAME       'Directory path too long
    strMsg$ = "Directory path too long."
    Case ERROR_ARC_READ_ONLY        'Unable to process write only archive file
    strMsg$ = "Unable to process write only archive file."
    Case ERROR_SAME_NAME_FILE       'File already exits in the archive file
    strMsg$ = "File already exits in the archive file."
    Case ERROR_NOT_FIND_ARC_FILE    'Unable to find LZH file at specified directory
    strMsg$ = "Unable to find LZH file at specified directory."
    Case Else
    strMsg$ = "Unrecognizable error!"
    End Select
    strMsg$ = strMsg$ & Chr$(13) & "Unable to extract file. Stopping file extraction. Err:" & intReturnCode%
    intType% = MB_OK Or MB_ICONEXCLAMATION
    LHAErrCode% = intReturnCode%
    MsgBox strMsg$, intType%, APP_CAPTION

End Function

'Execute after associating strFileName
'WinExec is used so allow concurrent execution
Sub LHAExecuteFile (strFilename As String)
    Dim intReturnCode       As Integer
    Dim strBuffer           As String * 128
    Dim strExecuteFile      As String
    Dim strOption           As String
    Dim strMsg              As String       'for MsgBox
    Dim intType             As Integer      'for MsgBox
    Dim intModuleCount      As Integer      'Module count of running programs
    Dim intTmpModuleCount   As Integer      'Temporary module count

    gstrUnpackDir$ = Left$(gstrTmpLzhFile$, InStr(gstrTmpLzhFile$, "\~wrk"))
    If IsFile(gstrUnpackDir$ & strFilename$) = True Then
    'File to be extracted is in the work directory
    strMsg$ = "File " & strFilename$ & " not found in work directory " & gstrUnpackDir$
    strMsg$ = strMsg$ & Chr$(10) & "Overwrite?"
    intType% = MB_OKCANCEL Or MB_ICONEXCLAMATION Or MB_DEFBUTTON2
    Select Case MsgBox(strMsg$, intType%, APP_CAPTION)
    Case IDCANCEL
        Exit Sub
    End Select
    End If
    strOption$ = "-n"   'Do not display extraction progress
    'Extract using Dir information?
    If gintbDirFlag% = True Then
    strOption$ = strOption$ & " -x"
    End If
    'Overwrite existing file?
    If gintbOverWriteFalg% = True Then
    strOption$ = strOption$ & " -c"
    End If
    'Extract file
    intReturnCode% = LHAUnpack(strFilename$, strOption$)
    If intReturnCode% <> 0 Then
    'Error extracting file
    Exit Sub
    End If
    'Get associated information
    intReturnCode% = FindExecutable(gstrUnpackDir$ & strFilename$, CurDir$, strBuffer$)
    Select Case intReturnCode%
    Case 2      'File not found
    If IsFile(gstrUnpackDir$ & Left$(strFilename$, 8)) = True Then
    'Files with long file name and without file extension
    'UNLHA.DLL uses only the first 8 characters of a file name.
        Call KillFile(gstrUnpackDir$ & Left$(strFilename$, 8))
    End If
    Case 0 To 32    'Display error check?
    strMsg$ = "Unable to find execution file. FindExecutable Err: " & intReturnCode%
    intType% = MB_OK Or MB_ICONEXCLAMATION Or MB_APPLMODAL
    MsgBox strMsg$, intType%, APP_CAPTION
    Call KillFile(gstrUnpackDir$ & strFilename$)
    Exit Sub
    End Select
    strExecuteFile$ = Left$(strBuffer$, InStr(strBuffer$, Chr$(0)) - 1)

    If strExecuteFile$ = "" Then
    'If no associated information, it could be an executable file
    Select Case GetFileExt(strFilename$)
    Case "PIF"
    Case "EXE"
    Case "COM"
    Case "BAT"
    Case Else
        'If no associated file and if not executable file
        'delete extracted file
        Call KillFile(gstrUnpackDir$ & strFilename$)
        Exit Sub
    End Select
    End If
    'Execute file
    intReturnCode% = WinExec(strExecuteFile$ & " " & gstrUnpackDir$ & strFilename$, SW_RESTORE)
    If intReturnCode% <= 32 Then
    strMsg$ = "Unable to execute file. WinExec Err: " & intReturnCode%
    intType% = MB_OK Or MB_ICONEXCLAMATION Or MB_APPLMODAL
    MsgBox strMsg$, intType%, APP_CAPTION
    'Delete executed file
    Call KillFile(gstrUnpackDir$ & strFilename$)
    Exit Sub
    End If
    intModuleCount% = GetModuleUsage(intReturnCode%)
    intTmpModuleCount% = intModuleCount%
    gintWorkCount% = gintWorkCount% + 1     'Number of running programs
    Do While intTmpModuleCount% = intModuleCount%
    'Loop referring to number of executing modules
    intModuleCount% = GetModuleUsage(intReturnCode%)
    DoEvents
    Loop
    'Delete extracted file
    Call KillFile(gstrUnpackDir$ & strFilename$)
    gintWorkCount% = gintWorkCount% - 1     'Number of running programs
End Sub

Function LHAGetFileInfo (DstForm As Form, strFilename As String) As String
    Dim intHarcHnd          As Integer
    Dim tagIndividualinfo   As INDIVIDUALINFO
    Dim intReturnCode       As Integer
    Dim strInfo              As String

    intHarcHnd% = UnlhaOpenArchive(DstForm.hWnd, gstrTmpLzhFile, 0)
    intReturnCode% = UnlhaFindFirst(intHarcHnd%, strFilename$, tagIndividualinfo)
    intReturnCode% = UnlhaCloseArchive(intHarcHnd%)
    strInfo$ = "File Name:" & Chr$(9) & Chr$(9) & Left$(tagIndividualinfo.szFileName, InStr(tagIndividualinfo.szFileName, Chr$(0)) - 1)
    strInfo$ = strInfo$ & Chr$(13) & Chr$(10) & "File Size:" & Chr$(9) & tagIndividualinfo.dwOriginalSize & "Bytes"
    strInfo$ = strInfo$ & Chr$(13) & Chr$(10) & "Archive Size▐:" & Chr$(9) & tagIndividualinfo.dwCompressedSize & "Bytes"
    strInfo$ = strInfo$ & Chr$(13) & Chr$(10) & "Comp. Ratio:" & Chr$(9) & Chr$(9) & tagIndividualinfo.wRatio / 10 & "%"
    strInfo$ = strInfo$ & Chr$(13) & Chr$(10) & "Date:" & Chr$(9) & Chr$(9) & (((tagIndividualinfo.wDate And &HFE00&) / 2 ^ 9) + 1980) & "-" & Format$(((tagIndividualinfo.wDate And &H1E0) / 2 ^ 5), "00") & "-" & Format$((tagIndividualinfo.wDate And &H1F), "00")
    strInfo$ = strInfo$ & Chr$(13) & Chr$(10) & "Time:" & Chr$(9) & Chr$(9) & Format$(((tagIndividualinfo.wTime And &HF800&) / 2 ^ 11), "00") & ":" & Format$(((tagIndividualinfo.wTime And &H7E0) / 2 ^ 5), "00") & ":" & Format$(((tagIndividualinfo.wTime And &H1F) * 2), "00")
    strInfo$ = strInfo$ & Chr$(13) & Chr$(10) & "CRC:" & Chr$(9) & Chr$(9) & Hex$(tagIndividualinfo.dwCRC)
    strInfo$ = strInfo$ & Chr$(13) & Chr$(10) & "File Attr:" & Chr$(9) & Left$(tagIndividualinfo.szAttribute, 4)
    strInfo$ = strInfo$ & Chr$(13) & Chr$(10) & "Comp. Type:" & Chr$(9) & Chr$(9) & Left$(tagIndividualinfo.szMode, 5)
    strInfo$ = strInfo$ & Chr$(13) & Chr$(10) & "OS:" & Chr$(9) & Chr$(9) & LHAGetOSType(tagIndividualinfo.uOSType)
    LHAGetFileInfo$ = strInfo$
End Function

Function LHAGetOSType (intType As Integer) As String
    Select Case intType%
    Case 0  'MS-DOS
    LHAGetOSType$ = "MS-DOS"
    Case 2  'UNIX
    LHAGetOSType$ = "UNIX"
    Case 4  'MAC-OS
    LHAGetOSType$ = "MAC-OS"
    Case 5  'OS/2
    LHAGetOSType$ = "OS/2"
    Case 10 'others
    LHAGetOSType$ = "Others"
    Case 11 'OS9
    LHAGetOSType$ = "OS9"
    Case 12 'OS/68K
    LHAGetOSType$ = "OS/68K"
    Case 13 'OS/386
    LHAGetOSType$ = "OS/386"
    Case 14 'HUMAN
    LHAGetOSType$ = "HUMAN"
    Case 15 'CP/M
    LHAGetOSType$ = "CP/M"
    Case 16 'FLEX
    LHAGetOSType$ = "FLEX"
    Case 17 'Runser
    LHAGetOSType$ = "Runser"
    Case -1 'Error
    LHAGetOSType$ = "Error"
    Case Else
    LHAGetOSType$ = "Undefined"
    End Select
End Function

'set text string from INDIVIDUALINFO structure in comparable format as "LHA l "
'SOme information may not be got depending on the display option.
Function LHAMakeList (tagIndividualinfo As INDIVIDUALINFO) As String
    Dim strTmp          As String
    Dim strArcList      As String
    Dim strWork         As String   'set to first directory starting with "/" in directory information present
    Dim intLoopCount    As Integer
    Dim intTmpFileLen   As Integer

    'get file name
    strTmp$ = Left$(tagIndividualinfo.szFileName, InStr(tagIndividualinfo.szFileName, Chr$(0)) - 1)
    'if directory information is included
    strArcList$ = Space$(2) & strTmp$ & Chr$(9)
    'set gintFilemaxLen% (global variable) to maximum file name length
    If gintFileMaxLen% < Len(strTmp$) Then
    gintFileMaxLen% = Len(strTmp$)
    End If

    If Mid$(gstrListViewOption$, 1, 1) = "1" Then
    'size
    strTmp$ = CStr(tagIndividualinfo.dwOriginalSize)
    strArcList$ = strArcList$ & Space$(8 - Len(strTmp$)) & strTmp$ & Space$(2)
    End If
    If Mid$(gstrListViewOption$, 2, 1) = "1" Then
    'archive size
    strTmp$ = CStr(tagIndividualinfo.dwCompressedSize)
    strArcList$ = strArcList$ & Space$(8 - Len(strTmp$)) & strTmp$ & Space$(1)
    End If
    If Mid$(gstrListViewOption$, 3, 1) = "1" Then
    'compression rate
    strTmp$ = Format$((tagIndividualinfo.wRatio / 10), "0.0") & "%"
    strArcList$ = strArcList$ & Space$(6 - Len(strTmp$)) & strTmp$ & Space$(1)
    End If
    If Mid$(gstrListViewOption$, 4, 1) = "1" Then
    'date
    strTmp$ = (((tagIndividualinfo.wDate And &HFE00&) / 2 ^ 9) + 80) & "-" & Format$(((tagIndividualinfo.wDate And &H1E0) / 2 ^ 5), "00") & "-" & Format$((tagIndividualinfo.wDate And &H1F), "00")
    strArcList$ = strArcList$ & strTmp$ & Space$(1)
    End If
    If Mid$(gstrListViewOption$, 5, 1) = "1" Then
    'time
    strTmp$ = Format$(((tagIndividualinfo.wTime And &HF800&) / 2 ^ 11), "00") & ":" & Format$(((tagIndividualinfo.wTime And &H7E0) / 2 ^ 5), "00") & ":" & Format$(((tagIndividualinfo.wTime And &H1F) * 2), "00")
    strArcList$ = strArcList$ & strTmp$ & Space$(1)
    End If
    If Mid$(gstrListViewOption$, 6, 1) = "1" Then
    'attributes
    strTmp$ = LCase$(Left$(tagIndividualinfo.szAttribute, 4))
    strArcList$ = strArcList$ & strTmp$ & Space$(1)
    End If
    If Mid$(gstrListViewOption$, 7, 1) = "1" Then
    'compression method
    strTmp$ = Left$(tagIndividualinfo.szMode, 5)
    strArcList$ = strArcList$ & LCase$(strTmp$) & Space$(1)
    End If
    If Mid$(gstrListViewOption$, 8, 1) = "1" Then
    'CRC
    strTmp$ = Hex$(tagIndividualinfo.dwCRC)
    'fill with "0" to always make it 4 digits
    strArcList$ = strArcList$ & String$(4 - Len(strTmp$), "0") & strTmp$
    End If
    LHAMakeList$ = RTrim$(strArcList$) & Space$(2)
End Function

'compression
Function LHAPack (strFilename As String) As Integer
    Dim intReturnCode   As Integer
    Dim strCommandLine  As String
    Dim strBuffer       As String * 10000
    Dim strOption       As String
    strOption$ = "-n "    'do not display extraction progress status
    strCommandLine$ = "a " & strOption$ & gstrTmpLzhFile$ & " " & strFilename$
    intReturnCode% = Unlha(strCommandLine$, strBuffer$, Len(strBuffer$))
    LHAPack = LHAErrCode(intReturnCode%)
    gintbSaveFlag% = True
End Function

Function LHAPackMove (strFilename As String) As Integer
    Dim intReturnCode   As Integer
    Dim strCommandLine  As String
    Dim strBuffer       As String * 10000
    strCommandLine$ = "m " & gstrTmpLzhFile$ & " " & strFilename$
    intReturnCode% = Unlha(strCommandLine$, strBuffer$, Len(strBuffer$))
    LHAPackMove% = LHAErrCode(intReturnCode%)
End Function

Sub LHASetMode ()
    Dim intReturnCode As Integer
    intReturnCode% = UnlhaSetBackGroundMode(0)  'run in background mode
    intReturnCode% = UnlhaSetCursorMode(1)      'display cursor
End Sub

Function LHASFX () As Integer
    Dim intReturnCode   As Integer
    Dim strCommandLine  As String
    Dim strBuffer       As String * 10000
    Dim strOption       As String
    strCommandLine$ = "s -jw -x1 -n " & gstrTmpLzhFile$
    intReturnCode% = Unlha(strCommandLine$, strBuffer$, Len(strBuffer$))
    LHASFX% = LHAErrCode(intReturnCode%)
    gintbSaveFlag% = True
End Function

Function LHATest (strFilename As String) As Integer
    Dim intReturnCode   As Integer
    Dim strCommandLine  As String
    Dim strBuffer       As String * 10000
    Dim strOption       As String
    strOption$ = " -n "    'do not display extraction progress status
    strCommandLine$ = "t " & strOption$ & gstrTmpLzhFile$ & " " & strFilename$
    intReturnCode% = Unlha(strCommandLine$, strBuffer$, Len(strBuffer$))
    LHATest% = LHAErrCode(intReturnCode%)
End Function

'extract
'   strFileName$ : name of file to extract
'   strOption$   : extraction options
Function LHAUnpack (strFilename As String, strOption As String) As Integer
    Dim intReturnCode   As Integer
    Dim strCommandLine  As String
    Dim strBuffer       As String * 10000
    If Len(strOption$) <> 0 Then strOption$ = strOption$ & " "
    strCommandLine$ = "e " & strOption$ & gstrTmpLzhFile$ & " " & gstrUnpackDir$ & " " & strFilename$
    intReturnCode% = Unlha(strCommandLine$, strBuffer$, Len(strBuffer$))
    LHAUnpack% = LHAErrCode(intReturnCode%)
End Function

Function LHAViewFile (strFilename As String) As String
    Dim intReturnCode   As Integer
    Dim strCommandLine  As String
    Dim strBuffer       As String * 10000
    Dim strOption       As String
    Dim strWork         As String
    strOption$ = "-n "    'do not display extraction progress status
    strCommandLine$ = "p " & strOption$ & gstrTmpLzhFile$ & " " & strFilename$
    intReturnCode% = Unlha(strCommandLine$, strBuffer$, Len(strBuffer$))
    If LHAErrCode(intReturnCode%) <> 0 Then Exit Function
    strWork$ = Left$(strBuffer, InStr(strBuffer$, Chr$(0)) - 1)
    If Len(strWork$) >= 9999 Then
    LHAViewFile$ = strWork$ & Chr$(13) & Chr$(10) & "[More...]"
    Else
    LHAViewFile$ = strWork$ & Chr$(13) & Chr$(10) & "[EOF]"
    End If
End Function

Sub Main ()
    Dim strMsg  As String
    Dim intType As Integer

    gintWinVer% = GetWindowsVersion()
    'check Windows version
    If gintWinVer% < 310 Then
    strMsg$ = "Windows 3.1 necessary to run " & APP_CAPTION & "."
    intType% = MB_OK Or MB_ICONEXCLAMATION
    MsgBox strMsg$, intType%, APP_CAPTION
    End
    End If
    'check if UNLHA.DLL exists
    If IsFile("UNLHA.DLL") = False Then
    strMsg$ = "File UNLHA.DLL necessary to run " & APP_CAPTION & "."
    intType% = MB_OK Or MB_ICONEXCLAMATION
    MsgBox strMsg$, intType%, APP_CAPTION
    End
    End If
    'check if minimum necessary memory is free
    If GetFreeSystemResources(GFSR_SYSTEMRESOURCES) < 20 Then    'not enough memory
    strMsg$ = "Not enough system resource" & Chr$(13)
    strMsg$ = strMsg$ & "Please end other applications and re-execute the program again."
    intType% = MB_OK Or MB_ICONSTOP
    MsgBox strMsg$, intType%, APP_CAPTION
    End
    End If
    'initialize UNLHA.DLL
    Call LHASetMode
    'check help file
    gstrHelpFile$ = App.EXEName & ".HLP"
    If IsFile(gstrHelpFile$) = True Then
    App.HelpFile = gstrHelpFile$
    Else
    gstrHelpFile$ = ""
    End If
    'get windows system color
    Call SetSystemColorValue
    'get size of windows
    Call SetSystemMetricsValue
    'initialize variables
    gintWorkCount% = 0

    'load main form
    Load frmArchive
End Sub

'---------------------------------------------------
'center new form to that of old form
'DstForm : form
'---------------------------------------------------
Sub SetChildWindowPos (ParentForm As Form, DstForm As Form)
    Dim intTmpLeft As Integer, intTmpTop As Integer
    'calculate horizontal position
    intTmpLeft = ParentForm.Left + ParentForm.Width \ 2 - DstForm.Width \ 2
    If intTmpLeft < 0 Then    'if past left edge of screen
    intTmpLeft = 0
    ElseIf intTmpLeft > Screen.Width - DstForm.Width Then
                  'if past right edge of screen
    intTmpLeft = Screen.Width - DstForm.Width
    End If
    'calculate vertical position
    intTmpTop = ParentForm.Top + ParentForm.Height \ 2 - DstForm.Height \ 2
    If intTmpTop < 0 Then     'if past top edge of screen
    intTmpTop = 0
    ElseIf intTmpTop > Screen.Height - DstForm.Height Then
                  'if past bottom edge of screen
    intTmpTop = Screen.Height - DstForm.Height
    End If
    DstForm.Left = intTmpLeft
    DstForm.Top = intTmpTop
End Sub

Sub SetCTL3DDLL (DstForm As Form, intFlag As Integer)
'Call CTL3D.DLL to create 3D effect.
'Use instance handle to set CTL3D.DLL as a subclass.
'Only use if EXE because if in VB mode, handle might not be
'released when program terminates.
    Dim intRetCode As Integer
    Dim intInstanceHandle As Integer

    If gintWinVer% > 310 Then Exit Sub              'quit if Windows above v3.1
    If IsVBRunTime() = False Then Exit Sub          'quit if VB.EXE executing
    If IsFile("CTL3D.DLL") = False Then Exit Sub    'quit if CTL3D.DLL not found
    If GetCtl3dVersion() < 2.01 Then Exit Sub       'if before ver 2.01 quit. (there is a bug)

    intInstanceHandle% = GetWindowWord(DstForm.hWnd, GWW_HINSTANCE)

    Select Case intFlag%
    Case True    'during Form load
    intRetCode% = Ctl3dRegister(intInstanceHandle%)
    intRetCode% = Ctl3dAutoSubClass(intInstanceHandle%)
    Case False   'during Form unload
    intRetCode% = Ctl3dUnregister(intInstanceHandle%)
    End Select
End Sub

Sub SetLstBoxAllSelect (DstListBox As ListBox, intbFlag As Integer)
    'Select all DstListBox list boxes
    Dim lngReturnCode As Long
    Select Case intbFlag%
    Case True
    lngReturnCode& = SendMessage(DstListBox.hWnd, LB_SETSEL, ByVal 1&, ByVal -1&)
    Case False
    lngReturnCode& = SendMessage(DstListBox.hWnd, LB_SETSEL, ByVal 0&, ByVal -1&)
    End Select
End Sub

Sub SetLstBoxHScrollBar (DstListBox As Control, intListWidth As Integer)
    Dim lngReturnCode      As Long
    'SendMessage to list box to display horizontal scroll bar
    lngReturnCode = SendMessage(DstListBox.hWnd, LB_SETHORIZONTALEXTENT, intListWidth%, 0&)
    DstListBox.Refresh
End Sub

Sub SetSystemColorValue ()
    glngColorBTNHIGHLIGHT = GetSysColor(COLOR_BTNHIGHLIGHT)
    glngColorBTNTEXT = GetSysColor(COLOR_BTNTEXT)
    glngColorBTNSHADOW = GetSysColor(COLOR_BTNSHADOW)
    glngColorBTNFACE = GetSysColor(COLOR_BTNFACE)
    glngColorWINDOW = GetSysColor(COLOR_WINDOW)
End Sub

Sub SetSystemMetricsValue ()

    gintCXBORDER% = GetSystemMetrics(SM_CXBORDER)
    gintCYBORDER% = GetSystemMetrics(SM_CYBORDER)
    gintCYCAPTION% = GetSystemMetrics(SM_CYCAPTION)
    gintCXDLGFRAME% = GetSystemMetrics(SM_CXDLGFRAME)
    gintCYDLGFRAME% = GetSystemMetrics(SM_CYDLGFRAME)
    gintCYCURSOR% = GetSystemMetrics(SM_CYCURSOR)
    gintCXVSCROLL% = GetSystemMetrics(SM_CXVSCROLL)
    gintCYHSCROLL% = GetSystemMetrics(SM_CYHSCROLL)
End Sub

Sub SetTextBoxReadOnly (DstTextBox As TextBox, intFlag As Integer)
    Dim lngReturnCode As Long
    Select Case intFlag%
    Case True
    lngReturnCode& = SendMessage(DstTextBox.hWnd, EM_SETREADONLY, 1, ByVal 0&)
    Case False
    lngReturnCode& = SendMessage(DstTextBox.hWnd, EM_SETREADONLY, 0, ByVal 0&)
    End Select
End Sub

Sub ShowToolTips (DstControl As Control, strMsg As String)
    Dim mPoint          As tagPoint
    Dim pRect           As tagRECT
    Dim intTmpLeft      As Integer
    Dim intTmpWidth     As Integer
    Dim intTmpTop       As Integer
    Dim intTmpHeight    As Integer

    If GetActiveWindow() <> DstControl.Parent.hWnd Then Exit Sub
    Load frmToolTips
    frmToolTips.AutoRedraw = True
    frmToolTips.Cls
    GetCursorPos mPoint
    GetWindowRect DstControl.hWnd, pRect

    intTmpLeft% = (pRect.Left + (pRect.Right - pRect.Left) \ 3) * Screen.TwipsPerPixelX
    intTmpWidth% = frmToolTips.TextWidth(strMsg$) + 2 * (gintCXBORDER + 3) * Screen.TwipsPerPixelX
    intTmpTop% = (mPoint.y + gintCYCURSOR) * Screen.TwipsPerPixelY
    intTmpHeight% = frmToolTips.TextHeight(strMsg$) + 2 * (gintCYBORDER + 2) * Screen.TwipsPerPixelY
    If intTmpLeft% < 0 Then intTmpLeft% = 0
    If intTmpLeft% > Screen.Width - intTmpWidth% Then intTmpLeft% = Screen.Width - intTmpWidth%
    If intTmpTop% > Screen.Height - intTmpHeight% Then intTmpTop% = pRect.Top * Screen.TwipsPerPixelY - intTmpHeight%

    'Does not work properly when old version of 3DWin (shareware) is running.
    frmToolTips.Move intTmpLeft%, intTmpTop%, intTmpWidth%, intTmpHeight%
    frmToolTips.CurrentX = 3 * Screen.TwipsPerPixelX
    frmToolTips.CurrentY = 2 * Screen.TwipsPerPixelY
    frmToolTips.Print strMsg$
    frmToolTips.AutoRedraw = False
End Sub